home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 001 / pibt40s4.arc / PROCESS3.MOD < prev    next >
Text File  |  1987-07-19  |  53KB  |  1,550 lines
  1. (*----------------------------------------------------------------------*)
  2. (*            Dispose_Proc_Stuff --- Dispose of proc stuff              *)
  3. (*----------------------------------------------------------------------*)
  4.  
  5. PROCEDURE Dispose_Proc_Stuff( Start, Last : INTEGER );
  6.  
  7. VAR
  8.    I: INTEGER;
  9.  
  10. BEGIN (* Dispose_Proc_Stuff *)
  11.  
  12.    FOR I := Start TO Last DO
  13.       IF ( Script_Procs[I].NArgs > 0 ) THEN
  14.          DISPOSE( Script_Procs[I].Type_Ptr );
  15.  
  16. END   (* Dispose_Proc_Stuff *);
  17.  
  18. (*----------------------------------------------------------------------*)
  19. (*            Label_Fixup --- Debug code for label fixups               *)
  20. (*----------------------------------------------------------------------*)
  21.  
  22. PROCEDURE Label_Fixup( IPos : INTEGER );
  23.  
  24. BEGIN (* Label_Fixup *)
  25.  
  26.    WRITELN( Script_Debug_File ,
  27.             '      Fixup at ', IPos:4,
  28.             ' to be ',NextP_Bytes[1]:4,
  29.             NextP_Bytes[2]:4, ' = ',NextP:8 );
  30.  
  31. END   (* Label_Fixup *);
  32.  
  33. (*----------------------------------------------------------------------*)
  34. (*           Emit_Proc --- Emit procedure call command                  *)
  35. (*----------------------------------------------------------------------*)
  36.  
  37. PROCEDURE Emit_Proc;
  38.  
  39. (*----------------------------------------------------------------------*)
  40. (*                                                                      *)
  41. (*     Procedure:  Emit_Proc                                            *)
  42. (*                                                                      *)
  43. (*     Purpose:    Emits procedure header code                          *)
  44. (*                                                                      *)
  45. (*     Calling Sequence:                                                *)
  46. (*                                                                      *)
  47. (*        Emit_Proc;                                                    *)
  48. (*                                                                      *)
  49. (*----------------------------------------------------------------------*)
  50.  
  51. VAR
  52.    I          : INTEGER;
  53.    J          : INTEGER;
  54.    QGotS      : BOOLEAN;
  55.    Token      : AnyStr;
  56.    PToken     : AnyStr;
  57.    Token_Type : OperandType;
  58.    Oper_Type  : OperType;
  59.    Index      : INTEGER;
  60.    NPArgs     : INTEGER;
  61.    PArgs      : Proc_Arg_Type_Vector;
  62.    PName      : ARRAY[1..MaxScriptArgs] OF STRING[12];
  63.    ProcName   : AnyStr;
  64.  
  65. BEGIN (* Emit_Proc *)
  66.                                    (* Assume command is bad.   *)
  67.    OK_Script_Command := FALSE;
  68.                                    (* Back up over ProcedureSy *)
  69.  
  70.    Script_Buffer_Pos := PRED( Script_Buffer_Pos );
  71.  
  72.                                    (* Increment count of defined procs *)
  73.  
  74.    Script_Proc_Count := SUCC( Script_Proc_Count );
  75.  
  76.                                    (* Increment procedure nesting level *)
  77.  
  78.    Script_Proc_Level := SUCC( Script_Proc_Level );
  79.  
  80.                                    (* Emit GOTO around this code,   *)
  81.                                    (* since it must be called to be *)
  82.                                    (* executed.                     *)
  83.  
  84.    Copy_Byte_To_Buffer( ORD( GoToSy ) );
  85.  
  86.    Script_Proc_Start := SUCC( Script_Buffer_Pos );
  87.  
  88.    Copy_Integer_To_Buffer( 0 , IntegerConsOnly );
  89.  
  90.                                    (* Record information on this script level *)
  91.  
  92.    WITH Script_Proc_Stack[Script_Proc_Level] DO
  93.       BEGIN
  94.          Old_VCount := Script_Variable_Kount;
  95.          Old_PCount := Script_Proc_Count;
  96.          GOTO_Pos   := Script_Proc_Start;
  97.       END;
  98.                                    (* Pick up procedure name *)
  99.  
  100.    QGotS := Get_Next_Token( ProcName, Token_Type, Oper_Type, Index );
  101.  
  102.                                    (* Pick up procedure arguments *)
  103.    NPArgs := 0;
  104.    QGots  := TRUE;
  105.  
  106.    WHILE( QGots AND ( NPArgs <= MaxScriptArgs ) ) DO
  107.       BEGIN
  108.                                    (* Get next argument. *)
  109.  
  110.          QGots := Get_Next_Token( Token, Token_Type, Oper_Type, Index );
  111.  
  112.          IF QGots THEN
  113.             BEGIN
  114.                                    (* Increment argument count. *)
  115.  
  116.                NPArgs := SUCC( NPArgs );
  117.  
  118.                                    (* Must be a name type *)
  119.  
  120.                IF ( NOT ( Token_Type IN [String_Variable_Type,
  121.                                         Integer_Variable_Type] ) ) THEN
  122.                   BEGIN
  123.                      Parse_Error( Token + ' <-- ' + S12 );
  124.                      EXIT;
  125.                   END;
  126.  
  127.                PName[NPArgs] := Token;
  128.  
  129.             END;
  130.                                    (* Get argument type *)
  131.          IF QGotS THEN
  132.             BEGIN
  133.  
  134.                PToken := Token;
  135.  
  136.                QGots  := Get_Next_Token( Token, Token_Type, Oper_Type, Index );
  137.  
  138.                Token  := UpperCase( Token );
  139.  
  140.                IF ( Token = 'STRING' ) THEN
  141.                   PArgs[NPArgs] := String_Variable_Type
  142.                ELSE IF ( Token = 'INTEGER' ) THEN
  143.                   PArgs[NPArgs] := Integer_Variable_Type
  144.                ELSE
  145.                   BEGIN
  146.                      Parse_Error( S10 + 'type after ' + PToken );
  147.                      EXIT;
  148.                   END;
  149.  
  150.             END;
  151.  
  152.       END;
  153.                                    (* Generate declares for arguments *)
  154.    FOR I := 1 TO NPArgs DO
  155.       BEGIN
  156.          IF ( PArgs[I] = String_Variable_Type ) THEN
  157.             Token := 'STRING '
  158.          ELSE
  159.             Token := 'INTEGER ';
  160.          Copy_Byte_To_Buffer( ORD( PImportSy ) );
  161.          Script_Line        := PName[I] + ' ' + Token;
  162.          Length_Script_Line := LENGTH( Script_Line );
  163.          IS                 := 0;
  164.          OK_Script_Command  := Parse_Declare_Command;
  165.       END;
  166.                                    (* Record information on this script *)
  167.    OK_Script_Command := TRUE;
  168.  
  169.    WITH Script_Procs[Script_Proc_Count] DO
  170.      BEGIN
  171.         Name       := UpperCase( ProcName );
  172.         Buffer_Pos := Script_Proc_Start + 2;
  173.         NArgs      := NPargs;
  174.         IF ( NPArgs = 0 ) THEN
  175.            Type_Ptr   := NIL
  176.         ELSE
  177.            BEGIN
  178.               NEW( Type_Ptr );
  179.               FOR I := 1 TO NPArgs DO
  180.                  Type_Ptr^[I] := PArgs[I];
  181.            END;
  182.      END;
  183.  
  184. END   (* Emit_Proc *);
  185.  
  186. (*----------------------------------------------------------------------*)
  187. (*           Emit_Return --- Emit procedure return command              *)
  188. (*----------------------------------------------------------------------*)
  189.  
  190. PROCEDURE Emit_Return( EndType : AnyStr );
  191.  
  192. (*----------------------------------------------------------------------*)
  193. (*                                                                      *)
  194. (*     Procedure:  Emit_Return                                          *)
  195. (*                                                                      *)
  196. (*     Purpose:    Emits return from procedure code                     *)
  197. (*                                                                      *)
  198. (*     Calling Sequence:                                                *)
  199. (*                                                                      *)
  200. (*        Emit_Return( EndType : AnyStr );                              *)
  201. (*                                                                      *)
  202. (*----------------------------------------------------------------------*)
  203.  
  204. BEGIN (* Emit_Return *)
  205.                                    (* Back up over command *)
  206.  
  207.    Script_Buffer_Pos := PRED( Script_Buffer_Pos );
  208.  
  209.                                    (* See if we have an open procedure    *)
  210.  
  211.    IF ( Script_Proc_Level <= 0 ) THEN
  212.       BEGIN
  213.          Parse_Error( S15 + EndType );
  214.          OK_Script_Command := FALSE;
  215.          EXIT;
  216.       END;
  217.                                    (* Issue ZapVars for local variables *)
  218.  
  219.    WITH Script_Proc_Stack[Script_Proc_Level] DO
  220.       BEGIN
  221.          IF ( Script_Variable_Kount > Old_VCount ) THEN
  222.             BEGIN
  223.                Copy_Byte_To_Buffer( ORD( ZapVarSy ) );
  224.                Copy_Integer_To_Buffer( Old_VCount + 1        , IntegerConstant );
  225.                Copy_Integer_To_Buffer( Script_Variable_Kount , IntegerConstant );
  226.             END;
  227.       END;
  228.                                    (* Emit ReturnSy so run-time goes back *)
  229.  
  230.    Copy_Byte_To_Buffer( ORD( ReturnSy ) );
  231.  
  232. END   (* Emit_Return *);
  233.  
  234. (*----------------------------------------------------------------------*)
  235. (*           Emit_EndProc --- Emit end of procedure code                *)
  236. (*----------------------------------------------------------------------*)
  237.  
  238. PROCEDURE Emit_EndProc;
  239.  
  240. (*----------------------------------------------------------------------*)
  241. (*                                                                      *)
  242. (*     Procedure:  Emit_EndProc                                         *)
  243. (*                                                                      *)
  244. (*     Purpose:    Emits end of procedure code                          *)
  245. (*                                                                      *)
  246. (*     Calling Sequence:                                                *)
  247. (*                                                                      *)
  248. (*        Emit_EndProc;                                                 *)
  249. (*                                                                      *)
  250. (*----------------------------------------------------------------------*)
  251.  
  252. VAR
  253.    I          : INTEGER;
  254.    J          : INTEGER;
  255.    QGotS      : BOOLEAN;
  256.    Token      : AnyStr;
  257.    Token_Type : OperandType;
  258.    Oper_Type  : OperType;
  259.    Index      : INTEGER;
  260.  
  261. BEGIN (* Emit_EndProc *)
  262.                                    (* Issue ReturnSy *)
  263.    Emit_Return( 'ENDPROC' );
  264.                                    (* Issue ZapVars for any local variables *)
  265.                                    (* declared in procedure.  Also, return  *)
  266.                                    (* variable count to count prior to the  *)
  267.                                    (* procedure declaration.                *)
  268.  
  269.    WITH Script_Proc_Stack[Script_Proc_Level] DO
  270.       BEGIN
  271.          IF ( Script_Variable_Kount > Old_VCount ) THEN
  272.             Script_Variable_Kount := Old_VCount;
  273.          IF ( Script_Proc_Count > Old_PCount ) THEN
  274.             BEGIN
  275.                Dispose_Proc_Stuff( Old_PCount + 1 , Script_Proc_Count );
  276.                Script_Proc_Count := Old_PCount;
  277.             END;
  278.          Script_Proc_Start := GOTO_Pos;
  279.       END;
  280.  
  281.    Script_Proc_Level := PRED( Script_Proc_Level );
  282.  
  283.                                    (* Now we know where procedure ends, *)
  284.                                    (* do a fixup                        *)
  285.  
  286.    NextP := SUCC( Script_Buffer_Pos );
  287.  
  288.    Script_Buffer^[ Script_Proc_Start     ] := NextP_Bytes[1];
  289.    Script_Buffer^[ Script_Proc_Start + 1 ] := NextP_Bytes[2];
  290.  
  291.    IF Script_Debug_Mode THEN
  292.       Label_Fixup( Script_Proc_Start );
  293.  
  294. END   (* Emit_EndProc *);
  295.  
  296. (*----------------------------------------------------------------------*)
  297. (*           Emit_Call --- Emit procedure call command                  *)
  298. (*----------------------------------------------------------------------*)
  299.  
  300. PROCEDURE Emit_Call;
  301.  
  302. (*----------------------------------------------------------------------*)
  303. (*                                                                      *)
  304. (*     Procedure:  Emit_Call                                            *)
  305. (*                                                                      *)
  306. (*     Purpose:    Emits procedure call command                         *)
  307. (*                                                                      *)
  308. (*     Calling Sequence:                                                *)
  309. (*                                                                      *)
  310. (*        Emit_Call;                                                    *)
  311. (*                                                                      *)
  312. (*----------------------------------------------------------------------*)
  313.  
  314. VAR
  315.    I          : INTEGER;
  316.    J          : INTEGER;
  317.    QGotS      : BOOLEAN;
  318.    Token      : AnyStr;
  319.    Token_Type : OperandType;
  320.    Oper_Type  : OperType;
  321.    Index      : INTEGER;
  322.  
  323. BEGIN (* Emit_Call *)
  324.                                    (* Back up over CallSy *)
  325.  
  326.    Script_Buffer_Pos := PRED( Script_Buffer_Pos );
  327.  
  328.                                    (* Get name of procedure to call *)
  329.  
  330.    QGotS := Get_Next_Token( Token, Token_Type, Oper_Type, Index );
  331.  
  332.                                    (* Look up procedure name *)
  333.    J     := 0;
  334.  
  335.    Token := UpperCase( Token );
  336.  
  337.    FOR I := Script_Proc_Count DOWNTO 1 DO
  338.       IF ( Token = Script_Procs[I].Name ) THEN
  339.          J := I;
  340.                                    (* Error if not found *)
  341.    IF ( J = 0 ) THEN
  342.       BEGIN
  343.          OK_Script_Command := FALSE;
  344.          Parse_Error( S21 + Token + S5 );
  345.          EXIT;
  346.       END
  347.    ELSE
  348.       I := Script_Procs[J].Buffer_Pos;
  349.  
  350.    Process_Call_List( '', Token_Type, I, J, OK_Script_Command );
  351.  
  352. END   (* Emit_Call *);
  353.  
  354. (*----------------------------------------------------------------------*)
  355. (*   Parse_Script_Command --- Parse and convert script to internal code *)
  356. (*----------------------------------------------------------------------*)
  357.  
  358. PROCEDURE Parse_Script_Command( VAR OK_Script_Command : BOOLEAN );
  359.  
  360. (*----------------------------------------------------------------------*)
  361. (*                                                                      *)
  362. (*     Procedure:  Parse_Script_Command                                 *)
  363. (*                                                                      *)
  364. (*     Purpose:    Parse and convert script line to internal code.      *)
  365. (*                                                                      *)
  366. (*     Calling Sequence:                                                *)
  367. (*                                                                      *)
  368. (*        Parse_Script_Command( VAR OK_Script_Command : BOOLEAN );      *)
  369. (*                                                                      *)
  370. (*           OK_Script_Command --- set TRUE if legitimate command       *)
  371. (*                                                                      *)
  372. (*----------------------------------------------------------------------*)
  373.  
  374. VAR
  375.    Qnum       : BOOLEAN;
  376.    QGotS      : BOOLEAN;
  377.    IntVal     : INTEGER;
  378.    ByteVal    : BYTE;
  379.    L          : INTEGER;
  380.    I          : INTEGER;
  381.    J          : INTEGER;
  382.    Index      : INTEGER;
  383.    SvPos      : INTEGER;
  384.    Token      : AnyStr;
  385.    Token_Type : OperandType;
  386.    Oper_Type  : OperType;
  387.    IntType    : INTEGER;
  388.  
  389. (* STRUCTURED *) CONST
  390.    Handle_Mess : STRING[21] = 'Handle not specified';
  391.  
  392. LABEL
  393.    LAddCommandSy,   LCallSy,        LCaptureSy,     LCaseSy,
  394.    LChDirSy,        LCloseSy,       LDeclareSy,     LDelaySy,
  395.    LDialSy,         LDoCaseSy,      LDosSy,         LElseSy,
  396.    LEndCaseSy,      LEndDoCaseSy,   LEndForSy,      LEndIfSy,
  397.    LEndProcSy,      LEndWhileSy,    LExecuteSy,     LExeNewSy,
  398.    LFileSy,         LForSy,         LGetDirSy,      LGetParamSy,
  399.    LGetVarSy,       LGoToXYSy,
  400.    LIfOpSy,         LImportSy,      LInputSy,       LKeyDefSy,
  401.    LKeySendSy,      LKeySy,         LMenuSy,
  402.    LMessageSy,      LOpenSy,        LParamSy,
  403.    LProcedureSy,    LQuitSy,        LReadSy,        LReadLnSy,
  404.    LReceiveSy,      LReDialSy,      LRepeatSy,      LRInputSy,
  405.    LScriptSy,       LSendSy,        LSetSy,         LSetVarSy,
  406.    LSTextSy,
  407.    LSuspendSy,      LTextSy,        LTranslateSy,   LUntilSy,
  408.    LWaitSy,         LWaitCountSy,   LWaitListSy,    LWaitQuietSy,
  409.    LWaitStrSy,      LWaitTimeSy,
  410.    LWhenSy,         LWhenDropSy,    LWhenListSy,    LWhereXYSy,
  411.    LWhileSy,
  412.    LWriteSy,        LWriteLnSy,     LSetParamSy,    LEndCase,
  413.    LReturnSy,       LWriteLogSy;
  414.  
  415. (*----------------------------------------------------------------------*)
  416. (*     Get_File_Reference --- Get file reference in I/O statement       *)
  417. (*----------------------------------------------------------------------*)
  418.  
  419. PROCEDURE Get_File_Reference;
  420.  
  421. VAR
  422.    File_Ref : INTEGER;
  423.    Ref_Type : INTEGER;
  424.  
  425. BEGIN (* Get_File_Reference *)
  426.  
  427.    SvPos := IS;
  428.  
  429.    QGotS := Get_Next_Token( Token, Token_Type, Oper_Type, Index );
  430.  
  431.    IF ( NOT QGots ) THEN
  432.       Parse_Error( Handle_Mess )
  433.    ELSE
  434.       CASE Token_Type OF
  435.  
  436.          Integer_Variable_Type : BEGIN
  437.                                     File_Ref := Index;
  438.                                     Ref_Type := IntegerVariable;
  439.                                  END;
  440.  
  441.          Integer_Constant_Type: BEGIN
  442.                                    File_Ref := Index;
  443.                                    Ref_Type := IntegerConstant;
  444.                                 END;
  445.  
  446.          ELSE                   BEGIN
  447.                                    File_Ref := 0;
  448.                                    Ref_Type := IntegerConstant;
  449.                                    IS       := SvPos;
  450.                                 END;
  451.       END (* CASE *);
  452.  
  453.    Copy_Integer_To_Buffer( File_Ref , Ref_Type );
  454.  
  455. END   (* Get_File_Reference *);
  456.  
  457. (*----------------------------------------------------------------------*)
  458. (*            Emit_EndIf --- Emit code for ENDIF statement              *)
  459. (*----------------------------------------------------------------------*)
  460.  
  461. PROCEDURE Emit_EndIf;
  462.  
  463. BEGIN (* Emit_EndIf *)
  464.  
  465.    IF ( Script_If_Level > 0 ) THEN
  466.       BEGIN
  467.  
  468.          J := Script_If_Stack[ Script_If_Level ];
  469.          Script_If_Level := PRED( Script_If_Level );
  470.  
  471.                                    (* Fixup GoTo before ELSE or   *)
  472.                                    (* FALSE branch in original IF *)
  473.                                    (* if no else.                 *)
  474.  
  475.          NextP := Script_Buffer_Pos;
  476.  
  477.          IF ( J > 0 ) THEN
  478.             BEGIN
  479.                Script_Buffer^[ J     ] := NextP_Bytes[1];
  480.                Script_Buffer^[ J + 1 ] := NextP_Bytes[2];
  481.                IF Script_Debug_Mode THEN
  482.                   Label_Fixup( J );
  483.             END
  484.          ELSE
  485.             BEGIN
  486.                J := -J;
  487.                Script_Buffer^[ J + 5 ] := NextP_Bytes[1];
  488.                Script_Buffer^[ J + 6 ] := NextP_Bytes[2];
  489.                IF Script_Debug_Mode THEN
  490.                   Label_Fixup( J + 5 );
  491.             END;
  492.  
  493.                                    (* Erase EndIf from buffer *)
  494.  
  495.          Script_Buffer_Pos := PRED( Script_Buffer_Pos );
  496.  
  497.       END
  498.    ELSE
  499.       OK_Script_Command := FALSE;
  500.  
  501. END   (* Emit_EndIf *);
  502.  
  503. (*----------------------------------------------------------------------*)
  504. (*            Emit_Else --- Emit code for ELSE statement                *)
  505. (*----------------------------------------------------------------------*)
  506.  
  507. PROCEDURE Emit_Else;
  508.  
  509. BEGIN (* Emit_Else *)
  510.  
  511.    IF ( Script_If_Level > 0 ) THEN
  512.       BEGIN
  513.  
  514.                                    (* Get address of IF statement *)
  515.                                    (* Remember offset is negative *)
  516.  
  517.          J := -Script_If_Stack[ Script_If_Level ];
  518.  
  519.                                    (* Back up over Else *)
  520.  
  521.          Script_Buffer_Pos := PRED( Script_Buffer_Pos );
  522.  
  523.                                    (* Insert GOTO here to branch  *)
  524.                                    (* around FALSE code.          *)
  525.  
  526.          Copy_Byte_To_Buffer( ORD( GoToSy ) );
  527.  
  528.                                    (* Address of GoTo not defined   *)
  529.                                    (* since we don't know it yet -- *)
  530.                                    (* leave it zero, and stuff the  *)
  531.                                    (* address of cell to receive    *)
  532.                                    (* fixup address later on IF     *)
  533.                                    (* stack.                        *)
  534.  
  535.          Script_If_Stack[ Script_If_Level ] := SUCC( Script_Buffer_Pos );
  536.  
  537.          Copy_Integer_To_Buffer( 0 , IntegerConsOnly );
  538.  
  539.                                    (* Fixup FALSE branch address in IF *)
  540.  
  541.          NextP := SUCC( Script_Buffer_Pos );
  542.  
  543.          Script_Buffer^[ J + 5 ] := NextP_Bytes[1];
  544.          Script_Buffer^[ J + 6 ] := NextP_Bytes[2];
  545.  
  546.          IF Script_Debug_Mode THEN
  547.             Label_Fixup( J + 5 );
  548.  
  549.       END
  550.    ELSE
  551.       OK_Script_Command := FALSE;
  552.  
  553. END   (* Emit_Else *);
  554.  
  555. (*----------------------------------------------------------------------*)
  556. (*            Emit_An_If --- Setup code for IF statement                *)
  557. (*----------------------------------------------------------------------*)
  558.  
  559. PROCEDURE Emit_An_If;
  560.  
  561. BEGIN (* Emit_An_If *)
  562.                                    (* Increment IF level *)
  563.  
  564.    Script_If_Level                      := SUCC( Script_If_Level );
  565.    Script_If_Stack[Script_If_Level]     := -Script_Buffer_Pos;
  566.    Script_ElseIf_Stack[Script_If_Level] := 0;
  567.  
  568.                                    (* Emit a conditional *)
  569.  
  570.    Emit_If_Command( 0 , OK_Script_Command );
  571.  
  572. END   (* Emit_An_If *);
  573.  
  574. (*----------------------------------------------------------------------*)
  575. (*            Emit_A_While --- Emit code for WHILE statement            *)
  576. (*----------------------------------------------------------------------*)
  577.  
  578. PROCEDURE Emit_A_While;
  579.  
  580. BEGIN (* Emit_A_While *)
  581.  
  582.    IF Script_Debug_Mode THEN
  583.       WRITELN( Script_Debug_File , 'Entered Emit_A_While' );
  584.  
  585.                                    (* Increment While level *)
  586.  
  587.    Script_While_Level := SUCC( Script_While_Level );
  588.    Script_While_Stack[Script_While_Level] := Script_Buffer_Pos;
  589.  
  590.                                    (* Emit conditional command *)
  591.  
  592.    Emit_If_Command( 0 , OK_Script_Command );
  593.  
  594. END   (* Emit_A_While *);
  595.  
  596. (*----------------------------------------------------------------------*)
  597. (*       Emit_An_EndWhile --- Emit code for ENDWHILE statement          *)
  598. (*----------------------------------------------------------------------*)
  599.  
  600. PROCEDURE Emit_An_EndWhile;
  601.  
  602. BEGIN (* Emit_An_EndWhile *)
  603.  
  604.    IF ( Script_While_Level > 0 ) THEN
  605.       BEGIN
  606.  
  607.          J := Script_While_Stack[ Script_While_Level ];
  608.          Script_While_Level := PRED( Script_While_Level );
  609.  
  610.          Script_Buffer^[Script_Buffer_Pos] := ORD( GoToSy );
  611.          Copy_Integer_To_Buffer( J , IntegerConsOnly );
  612.  
  613.          NextP := SUCC( Script_Buffer_Pos );
  614.  
  615.          Script_Buffer^[ J + 5 ] := NextP_Bytes[1];
  616.          Script_Buffer^[ J + 6 ] := NextP_Bytes[2];
  617.  
  618.          IF Script_Debug_Mode THEN
  619.             Label_Fixup( J + 5 );
  620.  
  621.       END
  622.    ELSE
  623.       Parse_Error( S15 + 'ENDWHILE');
  624.  
  625. END   (* Emit_An_EndWhile *);
  626.  
  627. (*----------------------------------------------------------------------*)
  628. (*           Emit_A_For --- Emit code for FOR statement                 *)
  629. (*----------------------------------------------------------------------*)
  630.  
  631. PROCEDURE Emit_A_For;
  632.  
  633. VAR
  634.    Ascending : BOOLEAN;
  635.    Dir_Chars : STRING[2];
  636.    L         : INTEGER;
  637.  
  638. BEGIN (* Emit_A_For *)
  639.                                    (* Generate initial SET *)
  640.  
  641.    Script_Buffer_Pos := PRED( Script_Buffer_Pos );
  642.  
  643.    Copy_Byte_To_Buffer( ORD( SetSy ) );
  644.  
  645.    IS := 0;
  646.  
  647.    Ascending := ( POS( 'DOWNTO' , UpperCase( Script_Line ) ) = 0 );
  648.  
  649.    CASE Ascending OF
  650.       TRUE:  BEGIN
  651.                 OK_Script_Command := Parse_Set_Command( 'TO' );
  652.                 Dir_Chars         := '<=';
  653.              END;
  654.       FALSE: BEGIN
  655.                 OK_Script_Command := Parse_Set_Command( 'DOWNTO' );
  656.                 Dir_Chars         := '>=';
  657.              END;
  658.    END (* CASE *);
  659. {
  660. IF Script_Debug_Mode THEN
  661.    BEGIN
  662.       WRITELN( Script_Debug_File, 'IS = ',IS,' after generating SET for FOR');
  663.       WRITELN( Script_Debug_File, 'Script_Line = <', Script_Line, '>');
  664.    END;
  665. }
  666.                                    (* If OK, generate WHILE *)
  667.    IF OK_Script_Command THEN
  668.       BEGIN
  669.                                    (* Get termination condition.       *)
  670.                                    (* We need to strip the trailing DO *)
  671.                                    (* if it appears.                   *)
  672.  
  673.          Script_Line := Trim( SubStr( Script_Line, SUCC( IS ),
  674.                                       Length_Script_Line - IS ) );
  675. {
  676.          IF Script_Debug_Mode THEN
  677.             WRITELN( Script_Debug_File, 'Script_Line = <', Script_Line, '>');
  678. }
  679.          L           := LENGTH( Script_Line );
  680.  
  681.          IF ( UpperCase( Substr( Script_Line, L - 1, 2 ) ) = 'DO' ) THEN
  682.             Script_Line := SUBSTR( Script_Line, 1, L - 2 );
  683. {
  684.          IF Script_Debug_Mode THEN
  685.                WRITELN( Script_Debug_File, 'Script_Line = <', Script_Line, '>');
  686. }
  687.          Script_Line := '( ' +
  688.                         Script_Vars[Result_Index].Var_Name +
  689.                         Dir_Chars +
  690.                         Script_Line +
  691.                         ' ) DO ';
  692.  
  693.          IF Script_Debug_Mode THEN
  694.             BEGIN
  695.                WRITELN( Script_Debug_File ,
  696.                         '      For generates <',
  697.                         Script_Line,'>' );
  698.             END;
  699.  
  700.          Length_Script_Line := LENGTH( Script_Line );
  701.          IS                 := 0;
  702.  
  703.          Script_Buffer_Pos  := SUCC( Script_Buffer_Pos );
  704.  
  705.          Emit_A_While;
  706.  
  707.          IF OK_Script_Command THEN
  708.             BEGIN
  709.                Script_For_Level := SUCC( Script_For_Level );
  710.                IF ( NOT Ascending ) THEN
  711.                   Result_Index := (-Result_Index);
  712.                Script_For_Stack[Script_For_Level] := Result_Index;
  713.             END;
  714.  
  715.       END;
  716.  
  717. END   (* Emit_A_For *);
  718.  
  719. (*----------------------------------------------------------------------*)
  720. (*           Emit_An_EndFor --- Emit code for ENDFOR statement          *)
  721. (*----------------------------------------------------------------------*)
  722.  
  723. PROCEDURE Emit_An_EndFor;
  724.  
  725. VAR
  726.    I         : INTEGER;
  727.    Dir_Chars : STRING[4];
  728.  
  729. BEGIN (* Emit_An_EndFor *)
  730.                                    (* Generate SET Statement *)
  731.  
  732.    IF ( Script_For_Level > 0 ) THEN
  733.       BEGIN
  734.  
  735.          I := Script_For_Stack[Script_For_Level];
  736.  
  737.          IF ( I > 0 ) THEN
  738.             Dir_Chars := '+ 1 '
  739.          ELSE
  740.             BEGIN
  741.                Dir_Chars := '- 1 ';
  742.                I         := -I;
  743.             END;
  744.  
  745.          Script_For_Level    := PRED( Script_For_Level );
  746.  
  747.          Script_Line         := Script_Vars[I].Var_Name +
  748.                                 '=' +
  749.                                 Script_Vars[I].Var_Name +
  750.                                 Dir_Chars;
  751.  
  752.          Script_Buffer_Pos := PRED( Script_Buffer_Pos );
  753.  
  754.          Copy_Byte_To_Buffer( ORD( SetSy ) );
  755.  
  756.          IS                  := 0;
  757.          Length_Script_Line  := LENGTH( Script_Line );
  758.          OK_Script_Command   := Parse_Set_Command( '' );
  759. {
  760.          IF Script_Debug_Mode THEN
  761.             BEGIN
  762.                WRITELN( Script_Debug_File ,
  763.                         '      EndFor generates <',
  764.                         Script_Line,'>' );
  765.             END;
  766. }
  767.                                    (* Generate ENDWHILE command *)
  768.  
  769.          Script_Buffer_Pos := SUCC( Script_Buffer_Pos );
  770.  
  771.          Emit_An_EndWhile;
  772.  
  773.       END
  774.    ELSE
  775.       Parse_Error( S15 + 'ENDFOR' );
  776.  
  777. END   (* Emit_An_EndFor *);
  778.  
  779. (*----------------------------------------------------------------------*)
  780. (*               Emit_Menu --- Emit code for MENU statement             *)
  781. (*----------------------------------------------------------------------*)
  782.  
  783. PROCEDURE Emit_Menu;
  784.  
  785. VAR
  786.    Qnum    : BOOLEAN;
  787.    IntVal  : INTEGER;
  788.    IntType : INTEGER;
  789.    ICountP : INTEGER;
  790.    SCount  : BYTE;
  791.    QGotS   : BOOLEAN;
  792.    MaxP    : INTEGER;
  793.    I       : INTEGER;
  794.  
  795. BEGIN (* Emit_Menu *)
  796.                                    (* Get variable index to receive *)
  797.                                    (* menu index                    *)
  798.    OK_Script_Command := FALSE;
  799.  
  800.    Get_Integer( QNum, I, IntType, TRUE );
  801.  
  802.    IF ( NOT Qnum ) THEN
  803.       BEGIN
  804.          IF ( IntType = IntegerMissing ) THEN
  805.             Parse_Error( S8 + COPY( S9, 2, LENGTH( S9 ) - 1 ) );
  806.          EXIT;
  807.       END;
  808.                                    (* Copy result index to buffer *)
  809.  
  810.    Copy_Integer_To_Buffer( I , IntType );
  811.  
  812.                                    (* Get column position *)
  813.  
  814.    Get_Integer( QNum, I, IntType, FALSE );
  815.    Copy_Integer_To_Buffer( I , IntType );
  816.  
  817.                                    (* Get row position *)
  818.  
  819.    Get_Integer( QNum, I, IntType, FALSE );
  820.    Copy_Integer_To_Buffer( I , IntType );
  821.  
  822.                                    (* Get default item *)
  823.  
  824.    Get_Integer( QNum, I, IntType, FALSE );
  825.    Copy_Integer_To_Buffer( I , IntType );
  826.  
  827.                                    (* Get title        *)
  828.  
  829.    Get_And_Copy_String_To_Buffer( FALSE , FALSE, QGotS );
  830.  
  831.                                    (* Leave space for # menu items *)
  832.    ICountP  := Script_Buffer_Pos;
  833.    Copy_Byte_To_Buffer( 0 );
  834.                                    (* Get menu item strings;   *)
  835.                                    (* may be strings or string *)
  836.                                    (* variables.               *)
  837.    OK_Script_Command := TRUE;
  838.    SCount            := 0;
  839.    QGots             := TRUE;
  840.                                    (* Get legitimate waitstrings *)
  841.  
  842.    WHILE( QGots AND OK_Script_Command AND ( SCount <= Max_Menu_Items ) ) DO
  843.       BEGIN
  844.          Get_And_Copy_String_To_Buffer( FALSE , FALSE, QGotS );
  845.          IF QGots THEN
  846.             SCount := SUCC( SCount );
  847.       END;
  848.                                    (* Enter count into buffer *)
  849.  
  850.    IntVal            := Script_Buffer_Pos;
  851.    Script_Buffer_Pos := ICountP;
  852.  
  853.    Copy_Byte_To_Buffer( SCount );
  854.  
  855.    Script_Buffer_Pos := IntVal;
  856.  
  857. END   (* Emit_Menu *);
  858.  
  859. (*----------------------------------------------------------------------*)
  860.  
  861. BEGIN (* Parse_Script_Command *)
  862.                                    (* Assume command is OK to start   *)
  863.    OK_Script_Command := TRUE;
  864.                                    (* Insert command type into buffer *)
  865.  
  866.    Copy_Byte_To_Buffer( ORD( Current_Script_Command ) );
  867.  
  868.                                    (* Pick up and insert command-dependent *)
  869.                                    (* information into script buffer.      *)
  870.    IS := 0;
  871. {
  872.    CASE Current_Script_Command OF
  873. }
  874.    IntVal := ORD( Current_Script_Command );
  875.  
  876.    INLINE(
  877.      $8B/$9E/>INTVAL        {  MOV     BX,[BP+>IntVal]    ;Pick up parameter # to set}
  878.      /$89/$D8               {  MOV     AX,BX              ;#}
  879.      /$D1/$E3               {  SHL     BX,1               ;# * 2}
  880.      /$01/$C3               {  ADD     BX,AX              ;# * 3}
  881.      /$B8/>*+6              {  MOV     AX,>*+6            ;Address of first GOTO}
  882.      /$01/$C3               {  ADD     BX,AX              ;Add offset of paramater}
  883.      /$FF/$E3               {  JMP     BX                 ;Branch to proper GOTO}
  884.    );
  885.  
  886.       GOTO LAddCommandSy;
  887.       GOTO LEndCase;
  888.       GOTO LEndCase;
  889.       GOTO LEndCase;
  890.       GOTO LEndCase;
  891.       GOTO LCallSy;
  892.       GOTO LCaptureSy;
  893.       GOTO LCaseSy;
  894.       GOTO LChDirSy;
  895.       GOTO LEndCase;
  896.       GOTO LCloseSy;
  897.       GOTO LEndCase;
  898.       GOTO LEndCase;
  899.       GOTO LDeclareSy;
  900.       GOTO LDelaySy;
  901.       GOTO LEndCase;
  902.       GOTO LDialSy;
  903.       GOTO LDoCaseSy;
  904.       GOTO LDosSy;
  905.       GOTO LEndCase;
  906.       GOTO LEndCase;
  907.       GOTO LElseSy;
  908.       GOTO LEndCase;
  909.       GOTO LEndCaseSy;
  910.       GOTO LEndDoCaseSy;
  911.       GOTO LEndForSy;
  912.       GOTO LEndIfSy;
  913.       GOTO LEndProcSy;
  914.       GOTO LEndWhileSy;
  915.       GOTO LExecuteSy;
  916.       GOTO LExeNewSy;
  917.       GOTO LEndCase;
  918.       GOTO LEndCase;
  919.       GOTO LEndCase;
  920.       GOTO LFileSy;
  921.       GOTO LForSy;
  922.       GOTO LGetDirSy;
  923.       GOTO LGetParamSy;
  924.       GOTO LGetVarSy;
  925.       GOTO LEndCase;
  926.       GOTO LEndCase;
  927.       GOTO LGoToXYSy;
  928.       GOTO LEndCase;
  929.       GOTO LEndCase;
  930.       GOTO LEndCase;
  931.       GOTO LEndCase;
  932.       GOTO LEndCase;
  933.       GOTO LEndCase;
  934.       GOTO LEndCase;
  935.       GOTO LEndCase;
  936.       GOTO LEndCase;
  937.       GOTO LIfOpSy;
  938.       GOTO LEndCase;
  939.       GOTO LImportSy;
  940.       GOTO LEndCase;
  941.       GOTO LInputSy;
  942.       GOTO LEndCase;
  943.       GOTO LKeyDefSy;
  944.       GOTO LEndCase;
  945.       GOTO LKeySendSy;
  946.       GOTO LKeySy;
  947.       GOTO LEndCase;
  948.       GOTO LEndCase;
  949.       GOTO LMenuSy;
  950.       GOTO LMessageSy;
  951.       GOTO LEndCase;
  952.       GOTO LOpenSy;
  953.       GOTO LParamSy;
  954.       GOTO LEndCase;
  955.       GOTO LProcedureSy;
  956.       GOTO LQuitSy;
  957.       GOTO LReadSy;
  958.       GOTO LReadLnSy;
  959.       GOTO LReceiveSy;
  960.       GOTO LReDialSy;
  961.       GOTO LRepeatSy;
  962.       GOTO LEndCase;
  963.       GOTO LReturnSy;
  964.       GOTO LRInputSy;
  965.       GOTO LScriptSy;
  966.       GOTO LEndCase;
  967.       GOTO LSendSy;
  968.       GOTO LSetSy;
  969.       GOTO LSetParamSy;
  970.       GOTO LSetVarSy;
  971.       GOTO LSTextSy;
  972.       GOTO LSuspendSy;
  973.       GOTO LTextSy;
  974.       GOTO LEndCase;
  975.       GOTO LTranslateSy;
  976.       GOTO LUntilSy;
  977.       GOTO LEndCase;
  978.       GOTO LWaitSy;
  979.       GOTO LWaitCountSy;
  980.       GOTO LWaitListSy;
  981.       GOTO LWaitQuietSy;
  982.       GOTO LWaitStrSy;
  983.       GOTO LWaitTimeSy;
  984.       GOTO LWhenSy;
  985.       GOTO LWhenDropSy;
  986.       GOTO LWhenListSy;
  987.       GOTO LWhereXYSy;
  988.       GOTO LWhileSy;
  989.       GOTO LWriteSy;
  990.       GOTO LWriteLnSy;
  991.       GOTO LWriteLogSy;
  992.       GOTO LEndCase;
  993.       GOTO LEndCase;
  994.       GOTO LEndCase;
  995.  
  996.       LAddCommandSy: IF Get_Next_Token( Token, Token_Type, Oper_Type, Index ) THEN
  997.                         IF ( Script_New_Command_Count < MaxNewCommands ) THEN
  998.                            BEGIN
  999.                               Script_New_Command_Count :=
  1000.                                  SUCC( Script_New_Command_Count );
  1001.                               Script_New_Commands[Script_New_Command_Count] :=
  1002.                                  UpperCase( Trim( Token ) );
  1003.                               Script_Buffer_Pos := PRED( Script_Buffer_Pos );
  1004.                            END
  1005.                         ELSE
  1006.                               Parse_Error('No room to store new command definition.')
  1007.                      ELSE
  1008.                         Parse_Error( S10 + 'new command name to define.');
  1009.                      GOTO LEndCase;
  1010.  
  1011.       LQuitSy      : Copy_Integer_To_Buffer( 1 , IntegerConsOnly );
  1012.                      GOTO LEndCase;
  1013.  
  1014.       LImportSy    : IF ( Script_Proc_Count > 0 ) THEN
  1015.                         IF ( Script_Proc_Level = 0 ) THEN
  1016.                            BEGIN
  1017.                               OK_Script_Command := FALSE;
  1018.                               Parse_Error( 'IMPORT' + S22 );
  1019.                            END
  1020.                         ELSE
  1021.                            BEGIN
  1022.                               OK_Script_Command := FALSE;
  1023.                               Parse_Error( S23 );
  1024.                            END
  1025.                      ELSE
  1026.                         BEGIN
  1027.                            OK_Script_Command := Parse_Declare_Command;
  1028.                            IF OK_Script_Command THEN
  1029.                               Import_Count := SUCC( Import_Count );
  1030.                         END;
  1031.                      GOTO LEndCase;
  1032.  
  1033.       LDeclareSy   : IF ( ( Script_Proc_Count > 0 ) AND
  1034.                           ( Script_Proc_Level = 0 ) ) THEN
  1035.                         BEGIN
  1036.                            OK_Script_Command := FALSE;
  1037.                            Parse_Error( 'DECLARE' + S22 );
  1038.                         END
  1039.                      ELSE
  1040.                         OK_Script_Command := Parse_Declare_Command;
  1041.                      GOTO LEndCase;
  1042.  
  1043.       LSuspendSy   :
  1044.       LDelaySy     :
  1045.       LWaitCountSy :
  1046.       LWaitQuietSy : BEGIN
  1047.                         Get_Integer( Qnum, IntVal, IntType, FALSE );
  1048.                         IF ( NOT Qnum ) THEN
  1049.                            BEGIN
  1050.                               IntVal  := 1;
  1051.                               IntType := IntegerConstant;
  1052.                            END;
  1053.                         Copy_Integer_To_Buffer( IntVal , IntType );
  1054.                         GOTO LEndCase;
  1055.                      END;
  1056.  
  1057.       LCaptureSy   :
  1058.       LGetDirSy    :
  1059.       LGetParamSy  :
  1060.       LKeyDefSy    :
  1061.       LReceiveSy   :
  1062.       LSendSy      :
  1063.       LSetParamSy  :
  1064.       LSetVarSy    :
  1065.       LWhenSy      : BEGIN
  1066.                         Get_And_Copy_String_To_Buffer( FALSE , TRUE, QGotS );
  1067.                         IF OK_Script_Command THEN
  1068.                            Get_And_Copy_String_To_Buffer( FALSE , TRUE, QGotS );
  1069.                         GOTO LEndCase;
  1070.                      END;
  1071.  
  1072.       LDialSy      : BEGIN
  1073.  
  1074.                         Get_And_Copy_String_To_Buffer( FALSE , TRUE, QGotS );
  1075.  
  1076.                         IF OK_Script_Command THEN
  1077.  
  1078.                                    (* See if NOSCRIPT appears *)
  1079.  
  1080.                            QGotS := Get_Next_Token( Token, Token_Type, Oper_Type, Index );
  1081.  
  1082.                         IF ( UpperCase( Token ) = 'NOSCRIPT' ) THEN
  1083.                            I := 1
  1084.                         ELSE
  1085.                            I := 0;
  1086.                                    (* Insert noscript flag in buffer *)
  1087.  
  1088.                         Copy_Integer_To_Buffer( I , IntegerConsOnly );
  1089.  
  1090.                         GOTO LEndCase;
  1091.  
  1092.                      END;
  1093.  
  1094.       LChDirSy     :
  1095.       LDosSy       :
  1096.       LKeySy       :
  1097.       LKeySendSy   :
  1098.       LMessageSy   :
  1099.       LReDialSy    :
  1100.       LSTextSy     :
  1101.       LTextSy      :
  1102.       LTranslateSy :
  1103.       LWaitSy      :
  1104.       LWhenDropSy  :
  1105.       LWriteLogSy  : Get_And_Copy_String_To_Buffer( FALSE , TRUE, QGotS );
  1106.                      GOTO LEndCase;
  1107.  
  1108.       LInputSy     : BEGIN
  1109.                                    (* Copy prompt string to script buffer *)
  1110.  
  1111.                         Get_And_Copy_String_To_Buffer( FALSE , TRUE, QGotS );
  1112.  
  1113.                                    (* See if variable name follows.  If so, *)
  1114.                                    (* that will be receiving variable.      *)
  1115.                                    (* If not, just leave in standard input  *)
  1116.                                    (* buffer.                               *)
  1117.  
  1118.                         IF ( OK_Script_Command ) THEN
  1119.                            Get_And_Copy_String_To_Buffer( TRUE , TRUE, QGotS );
  1120.  
  1121.                         GOTO LEndCase;
  1122.  
  1123.                      END;
  1124.  
  1125.       LRInputSy    : BEGIN
  1126.                                    (* Copy prompt string to script buffer *)
  1127.  
  1128.                         Get_And_Copy_String_To_Buffer( FALSE , TRUE, QGotS );
  1129.  
  1130.                                    (* Assume echo mode *)
  1131.                         I := 1;
  1132.                                    (* See if NOECHO appears *)
  1133.  
  1134.                         QGotS := Get_Next_Token( Token, Token_Type, Oper_Type, Index );
  1135.  
  1136.                         IF ( UpperCase( Token ) = 'NOECHO' ) THEN
  1137.                            I := 0;
  1138.  
  1139.                                    (* Insert echo/noecho flag in buffer *)
  1140.  
  1141.                         Copy_Integer_To_Buffer( I , IntegerConsOnly );
  1142.  
  1143.                                    (* See if var name follows.          *)
  1144.  
  1145.                         IF OK_Script_Command THEN
  1146.                            Get_And_Copy_String_To_Buffer( TRUE , TRUE, QGotS );
  1147.  
  1148.                         GOTO LEndCase;
  1149.  
  1150.                      END;
  1151.  
  1152.       LIfOpSy      : Emit_An_If;
  1153.                      GOTO LEndCase;
  1154.  
  1155.       LElseSy      : Emit_Else;
  1156.                      GOTO LEndCase;
  1157.  
  1158.       LEndIfSy     : Emit_Endif;
  1159.                      GOTO LEndCase;
  1160.  
  1161.       LGoToXYSy    : BEGIN
  1162.                         Get_Integer( QNum, I, IntType, FALSE );
  1163.                         IF ( NOT Qnum ) THEN
  1164.                            BEGIN
  1165.                               IntVal  := 1;
  1166.                               IntType := IntegerConstant;
  1167.                            END;
  1168.                         Copy_Integer_To_Buffer( I , IntType );
  1169.                         Get_Integer( QNum, I, IntType, FALSE );
  1170.                         IF ( NOT Qnum ) THEN
  1171.                            BEGIN
  1172.                               IntVal  := 1;
  1173.                               IntType := IntegerConstant;
  1174.                            END;
  1175.                         Copy_Integer_To_Buffer( I , IntType );
  1176.                         GOTO LEndCase;
  1177.                      END;
  1178.  
  1179.       LWaitStrSy   : Emit_Wait_String_Command( OK_Script_Command );
  1180.                      GOTO LEndCase;
  1181.  
  1182.       LSetSy       : BEGIN
  1183.                         IS                := 0;
  1184.                         OK_Script_Command := Parse_Set_Command( '' );
  1185.                         GOTO LEndCase;
  1186.                      END;
  1187.  
  1188.       LRepeatSy    : BEGIN
  1189.                                    (* Increment repeat level *)
  1190.  
  1191.                         Script_Repeat_Level := SUCC( Script_Repeat_Level );
  1192.  
  1193.                                    (* Remember where repeat starts. *)
  1194.  
  1195.                         Script_Repeat_Stack[Script_Repeat_Level] :=
  1196.                            Script_Buffer_Pos;
  1197.  
  1198.                                    (* Erase repeat command *)
  1199.  
  1200.                         Script_Buffer_Pos   := PRED( Script_Buffer_Pos );
  1201.  
  1202.                         GOTO LEndCase;
  1203.  
  1204.                      END;
  1205.  
  1206.       LUntilSy     : BEGIN
  1207.                         IF ( Script_Repeat_Level > 0 ) THEN
  1208.                            BEGIN
  1209.  
  1210.                                    (* Pop REPEAT address off stack *)
  1211.  
  1212.                               J := Script_Repeat_Stack[ Script_Repeat_Level ];
  1213.                               Script_Repeat_Level := PRED( Script_Repeat_Level );
  1214.  
  1215.                                    (* Emit end of loop test *)
  1216.  
  1217.                               Emit_If_Command( J , OK_Script_Command );
  1218.  
  1219.                           END
  1220.                         ELSE
  1221.                            OK_Script_Command := FALSE;
  1222.  
  1223.                         GOTO LEndCase;
  1224.  
  1225.                      END;
  1226.  
  1227.       LWhileSy     : Emit_A_While;
  1228.                      GOTO LEndCase;
  1229.  
  1230.       LEndWhileSy  : Emit_An_EndWhile;
  1231.                      GOTO LEndCase;
  1232.  
  1233.       LParamSy     : BEGIN
  1234.  
  1235.                         QGotS := Get_Next_Token( Token, Token_Type, Oper_Type, Index );
  1236.  
  1237.                         Copy_Byte_To_Buffer( ORD( Token[1] ) );
  1238.                         Copy_Byte_To_Buffer( ORD( Token[2] ) );
  1239.  
  1240.                         QGotS := Get_Next_Token( Token, Token_Type, Oper_Type, Index );
  1241.  
  1242.                         IF ( Token <> '=' ) THEN
  1243.                            Parse_Error( S10 + '=' )
  1244.                         ELSE
  1245.                            BEGIN
  1246.                               Token := Substr( Script_Line, IS + 1,
  1247.                                                Length_Script_Line - IS );
  1248.                               L     := LENGTH( Token );
  1249.                               Copy_Byte_To_Buffer( L );
  1250.                               FOR I := 1 TO L DO
  1251.                                  Copy_Byte_To_Buffer( ORD( Token[I] ) );
  1252.                            END;
  1253.  
  1254.                         GOTO LEndCase;
  1255.  
  1256.                      END;
  1257.  
  1258.       LProcedureSy : Emit_Proc;
  1259.                      GOTO LEndCase;
  1260.  
  1261.       LEndProcSy   : Emit_EndProc;
  1262.                      GOTO LEndCase;
  1263.  
  1264.       LCallSy      : Emit_Call;
  1265.                      GOTO LEndCase;
  1266.  
  1267.       LScriptSy    : BEGIN
  1268.  
  1269.                         QGotS := Get_Next_Token( Token, Token_Type, Oper_Type, Index );
  1270.  
  1271.                         Copy_Byte_To_Buffer( ORD( Token[1] ) );
  1272.  
  1273.                         Get_And_Copy_String_To_Buffer( FALSE , TRUE, QGotS );
  1274.  
  1275.                         GOTO LEndCase;
  1276.  
  1277.                      END;
  1278.  
  1279.       LCloseSy     : BEGIN
  1280.  
  1281.                         Get_Integer( QNum, I, IntType, FALSE );
  1282.  
  1283.                         IF ( NOT Qnum ) THEN
  1284.                            Parse_Error( Handle_Mess );
  1285.  
  1286.                         Copy_Integer_To_Buffer( I , IntType );
  1287.  
  1288.                         GOTO LEndCase;
  1289.                      END;
  1290.  
  1291.       LReadLnSy    : BEGIN
  1292.  
  1293.                         Get_File_Reference;
  1294.  
  1295.                         Get_And_Copy_String_To_Buffer( TRUE , TRUE, QGotS );
  1296.  
  1297.                         GOTO LEndCase;
  1298.  
  1299.                      END;
  1300.  
  1301.       LReadSy      : BEGIN
  1302.  
  1303.                         Get_File_Reference;
  1304.  
  1305.                         Get_And_Copy_String_To_Buffer( TRUE , TRUE, QGotS );
  1306.  
  1307.                         Get_Integer( QNum, I, IntType, FALSE );
  1308.  
  1309.                         IF ( NOT Qnum ) THEN
  1310.                            I := 1;
  1311.  
  1312.                         Copy_Integer_To_Buffer( I , IntType );
  1313.  
  1314.                         GOTO LEndCase;
  1315.  
  1316.                      END;
  1317.  
  1318.       LWriteLnSy   : BEGIN
  1319.  
  1320.                         Get_File_Reference;
  1321.  
  1322.                         Get_And_Copy_String_To_Buffer( FALSE , TRUE, QGotS );
  1323.  
  1324.                         GOTO LEndCase;
  1325.  
  1326.                      END;
  1327.  
  1328.       LWriteSy     : BEGIN
  1329.  
  1330.                         Get_File_Reference;
  1331.  
  1332.                         Get_And_Copy_String_To_Buffer( FALSE , TRUE, QGotS );
  1333.  
  1334.                         GOTO LEndCase;
  1335.  
  1336.                      END;
  1337.  
  1338.       LOpenSy      : BEGIN
  1339.  
  1340.                         Get_Integer( QNum, I, IntType, FALSE );
  1341.  
  1342.                         IF ( NOT Qnum ) THEN
  1343.                            Parse_Error( Handle_Mess );
  1344.  
  1345.                         Copy_Integer_To_Buffer( I , IntType );
  1346.  
  1347.                         Get_And_Copy_String_To_Buffer( FALSE , TRUE, QGotS );
  1348.  
  1349.                         IF ( NOT Get_Next_Token( Token, Token_Type, Oper_Type, Index ) ) THEN
  1350.                            Parse_Error( S18 + '"input", "output", or "append"' )
  1351.                         ELSE
  1352.                            BEGIN
  1353.                               CASE UpCase(Token[1]) OF
  1354.                                  'I':  I := 0;
  1355.                                  'A':  I := 2;
  1356.                               ELSE
  1357.                                  I := 1;
  1358.                               END (* CASE *);
  1359.                               Copy_Integer_To_Buffer( I , IntType );
  1360.                            END;
  1361.  
  1362.                         GOTO LEndCase;
  1363.  
  1364.                      END;
  1365.  
  1366.       LDoCaseSy    : BEGIN
  1367.                                    (* Back up over DoCaseSy *)
  1368.  
  1369.                         Script_Buffer_Pos := PRED( Script_Buffer_Pos );
  1370.  
  1371.                                    (* Increment count of defined cases *)
  1372.  
  1373.                         Script_Case_Level := SUCC( Script_Case_Level );
  1374.  
  1375.                                    (* Pick up case variable name *)
  1376.  
  1377.                         IF ( NOT Get_Next_Token( Token, Token_Type, Oper_Type, Index ) ) THEN
  1378.                            Parse_Error( S10 + 'case variable.' )
  1379.                         ELSE
  1380.                            BEGIN
  1381.                               IF ( Token_Type IN [String_Variable_Type,
  1382.                                                   Integer_Variable_Type] ) THEN
  1383.                                  BEGIN
  1384.                                     Script_Case_Var_Stack[Script_Case_Level] := Index;
  1385.                                     Script_Case_Cnt_Stack[Script_Case_Level] := 0;
  1386.                                  END
  1387.                               ELSE
  1388.                                  Parse_Error( S18 + Token + S3 );
  1389.                            END;
  1390.  
  1391.                         GOTO LEndCase;
  1392.  
  1393.                      END;
  1394.  
  1395.       LEndDoCaseSy : BEGIN
  1396.  
  1397.                         IF ( Script_Case_Level > 0 ) THEN
  1398.                            BEGIN
  1399.                               FOR J := 1 TO Script_Case_Cnt_Stack[Script_Case_Level] DO
  1400.                                  BEGIN
  1401.                                     Emit_EndIf;
  1402.                                     Script_Buffer_Pos := SUCC( Script_Buffer_Pos );
  1403.                                  END;
  1404.                               Script_Case_Level := PRED( Script_Case_Level );
  1405.                               Script_Buffer_Pos := PRED( Script_Buffer_Pos );
  1406.                            END
  1407.                         ELSE
  1408.                            Parse_Error( S15 + 'ENDDOCASE' );
  1409.  
  1410.                         GOTO LEndCase;
  1411.  
  1412.                      END;
  1413.  
  1414.       LCaseSy      : BEGIN
  1415.                                    (* See if this is ELSE -- in which *)
  1416.                                    (* case, generate nothing.         *)
  1417.  
  1418.                         IF ( NOT Get_Next_Token( Token, Token_Type, Oper_Type, Index ) ) THEN
  1419.                            Parse_Error( S10 + 'case expression.' )
  1420.  
  1421.                         ELSE IF ( UpperCase( Token ) <> 'ELSE') THEN
  1422.                            BEGIN
  1423.  
  1424.                                    (* Increment count of cases found  *)
  1425.  
  1426.                               Script_Case_Cnt_Stack[Script_Case_Level] :=
  1427.                                  SUCC( Script_Case_Cnt_Stack[Script_Case_Level] );
  1428.  
  1429.                                    (* Increment IF level *)
  1430.  
  1431.                               Script_If_Level := SUCC( Script_If_Level );
  1432.                               Script_If_Stack[Script_If_Level] :=
  1433.                                  -Script_Buffer_Pos;
  1434.  
  1435.                                    (* Generate IF Statement *)
  1436.  
  1437.                               I := Script_Case_Var_Stack[Script_Case_Level];
  1438.  
  1439.                               Script_Line := '(' +
  1440.                                              Script_Vars[I].Var_Name +
  1441.                                              '=' + Script_Line + ') THEN ';
  1442.  
  1443.                               IS                 := 0;
  1444.                               Length_Script_Line := LENGTH( Script_Line );
  1445.  
  1446.                               IF Script_Debug_Mode THEN
  1447.                                  BEGIN
  1448.                                     WRITELN( Script_Debug_File ,
  1449.                                              '      Case generates <',
  1450.                                              Script_Line,'>' );
  1451.                                  END;
  1452.  
  1453.                                    (* Emit a conditional *)
  1454.  
  1455.                               Emit_If_Command( 0 , OK_Script_Command );
  1456.  
  1457.                            END
  1458.                         ELSE
  1459.                            Script_Case_Var_Stack[Script_Case_Level] := 0;
  1460.  
  1461.                         GOTO LEndCase;
  1462.  
  1463.                      END;
  1464.  
  1465.       LEndCaseSy   : IF ( Script_Case_Var_Stack[Script_Case_Level] <> 0 ) THEN
  1466.                         Emit_Else
  1467.                      ELSE
  1468.                         Script_Buffer_Pos := PRED( Script_Buffer_Pos );
  1469.  
  1470.                      GOTO LEndCase;
  1471.  
  1472.       LForSy       : Emit_A_For;
  1473.                      GOTO LEndCase;
  1474.  
  1475.       LEndForSy    : Emit_An_EndFor;
  1476.                      GOTO LEndCase;
  1477.  
  1478.       LWhereXYSy   : BEGIN
  1479.  
  1480.                         Get_Integer( QNum, I, IntType, TRUE );
  1481.  
  1482.                         Copy_Integer_To_Buffer( I , IntType );
  1483.  
  1484.                         Get_Integer( QNum, I, IntType, TRUE );
  1485.  
  1486.                         Copy_Integer_To_Buffer( I , IntType );
  1487.  
  1488.                         GOTO LEndCase;
  1489.  
  1490.                      END;
  1491.  
  1492.       LExecuteSy   : Emit_Execute_Command ( OK_Script_Command );
  1493.                      GOTO LEndCase;
  1494.  
  1495.       LWaitListSy  : Emit_WaitList_Command( OK_Script_Command );
  1496.                      GOTO LEndCase;
  1497.  
  1498.       LExeNewSy    : BEGIN
  1499.  
  1500.                         Copy_String_To_Buffer( Script_Command_Token, String_Constant_Type, 0 );
  1501.  
  1502.                         Copy_String_To_Buffer( Script_Line, String_Constant_Type, 0 );
  1503.  
  1504.                         GOTO LEndCase;
  1505.  
  1506.                      END;
  1507.  
  1508.       LWaitTimeSy  : BEGIN
  1509.  
  1510.                         Get_Integer( QNum, I, IntType, FALSE );
  1511.  
  1512.                         IF ( NOT QNum ) THEN
  1513.                            BEGIN
  1514.                               I       := 30;
  1515.                               IntType := IntegerConstant;
  1516.                            END;
  1517.  
  1518.                         Copy_Integer_To_Buffer( I , IntType );
  1519.  
  1520.                         GOTO LEndCase;
  1521.  
  1522.                      END;
  1523.  
  1524.       LWhenListSy  : GOTO LEndCase;
  1525.       LFileSy      : GOTO LEndCase;
  1526.  
  1527.       LMenuSy      : Emit_Menu;
  1528.                      GOTO LEndCase;
  1529.  
  1530.       LReturnSy    : Emit_Return( 'RETURN' );
  1531.                      GOTO LEndCase;
  1532.  
  1533.       LGetVarSy    : BEGIN
  1534.                         Get_And_Copy_String_To_Buffer( FALSE , TRUE, QGotS );
  1535.                         IF OK_Script_Command THEN
  1536.                            Get_And_Copy_String_To_Buffer( TRUE , TRUE, QGotS );
  1537.                         IF OK_Script_Command THEN
  1538.                            Get_And_Copy_String_To_Buffer( TRUE , TRUE, QGotS );
  1539.                         GOTO LEndCase;
  1540.                      END;
  1541. {
  1542.       ELSE;
  1543.  
  1544.    END (* CASE *);
  1545. }
  1546.    LEndCase    : ;
  1547.  
  1548. END   (* Parse_Script_Command *);
  1549.  
  1550.